Shareware Grab Bag/Shareware Grab Bag.iso/003/chrchpr2.arc/CSELODGE.CMD

Text File | 1979-12-31 | 8.0 KB | 294 lines

* Program CSELODGE - Tracks lodging assignments
Select secondary
Store 'ROOM=' to infield
If len(MSEL) > 1
  Store msel+'  ' to msel
  Store $(msel,2,3) to inlodg
  Store infield+inlodg to sfield
  Find &sfield
  If #=0
    Accept 'Lodging code not found. Press <return> ' to xx
    RETURN
  endif
else
 ? '       ',ename,'   LODGING names             '+curdate
 Find &INFIELD
 If #=0
Accept 'No Lodgings found. You must enter some from SET UP. Press <retn>' to XX
  RETURN
 endif
 Store ' ' to romvalid
 Set raw on
 Do while spact=infield
  Store romvalid+$(spact,5,4) to romvalid
  Store $(spact,1,9) to innf
  ? '[',$(spact,6,3),']  ',$(spact,9,30)
  Do while spact=innf.or.$(spact,9,1)='.'
    SKIP
  enddo
 enddo
 Store 'Y' to xsel
 ?
 ? 'VALID LODGING CODES: ',romvalid
 Set raw off
 ?
 Accept '         Select a Lodging code (3 characters) ' to inlodg
 Store F to goodlodg
 Do while .not. goodlodg
  Store $(inlodg,1,3) to inlodg
  Store '='+inlodg to innlodge
  Store T to goodlodg
  If !(inlodg)='Q' .and. len(inlodg)=1
    Store T to goodlodg
    Store 'Q  ' to inlodg
  else
   If @(innlodge,romvalid)=0
    Accept 'Lodging code is not found. Enter another ' to inlodg
    Store F to goodlodg
   else
    Store 'ROOM'+innlodge to sfield
    Find &sfield
    If #=0
      Accept 'Lodging code is not found.  Enter another' to inlodg
      Store 'n' to xsel
      Store F to goodlodg
    endif
   endif
  endif
enddo
endif
If inlodg<>'Q  '
Store '['+$(spact,6,3)+'] '+trim($(spact,9,30)) to romname
Store $(spact,1,9) to sfield
Release inlodg,romvalid,goodlodg,innlodge,innf
Store ' ' to xsel
Store str(#,5) to xrec
Do while !(xsel)<>'Q'
Select secondary
GOTO &xrec
SKIP
Erase
@ 1,0 say ROMNAME+'    '+ename
@ 1,64 say curdate
Store 3 to I
Store 3 to J
Do while spact=sfield .and. .not. EOF
  Store 3 to I
  Store 3 to J
  Do while J<80 .and. spact=sfield .and. .not. EOF
    @ I,J say $(spact,9,30)
    SKIP
    store I+1 to I
    If I=23
      Store J+40 to J
      Store 3 to I
    endif
  enddo
 enddo
 Store ' ' to xsel
 Store I-3 to II
 If J=43
   Store II+20 to II
 endif
 Do while !(xsel)<>'Q'.and.!(xsel)<>'S'
   @ 22,78 say ' '
   Accept ;
   'Select:  A]dd   C]hange   D]elete   R]eport   S]creen   V]erify   Q]uit ' ;
   to xsel
   Do CASE
   CASE !(xsel)='V'
     Select secondary
     GOTO &xrec
     SKIP
     If spact<>sfield
       Accept "No names are assigned to this Lodging.  Press <retn>" to xx
     else
? 'Now verifying EDIRFILE names against Lodging assignments in MEMBERSE.'
?? date()
? 'This routine clears any names in the EDIRFILE that do not match in MEMBERSE'
Accept 'OK? ' to xx
     If !(xx)='Y'
       Do while spact=sfield
         Store $(spact,15,11) to nfind
         Store trim($(spact,27,10)) to ffind
         Select primary
         Store F to nfound
         If NFIND<>'           '
          Find &NFIND
          If #<>0
           Do while last:name=nfind .and. first:name<>ffind.and. .not. EOF
             SKIP
           enddo
           If last:name=nfind.and. first:name=ffind
             Store T to nfound
           endif
          endif
          If nfound
           If $(S.spact,6,9)=room
             ? room,'   ',nfind,ffind,'   > > >   VERIFIED   < < <'
           else
             ? room,'   ',nfind,ffind,'   Lodging does not match in MEMBERSE '
             Select secondary
             SKIP -1
             Store str(#,5) to orec
             SKIP
             Replace spact with $(spact,1,14)
             GOTO &orec
           endif
          else
           ? '             ',nfind,ffind,'   Name is not found in MEMBERSE.'
           Select secondary
           SKIP -1
           Store str(#,5) to orec
           SKIP
           Replace spact with $(spact,1,14)
           GOTO &OREC
          endif
         endif
         Select secondary
         SKIP
       enddo
     endif
   CASE !(xsel)='A'
    If II>39
Accept 'Maximum assignments for this Lodging have been reached. Press <retn>' ;
to xx
    else
     Select secondary
     Store xsel+'      ' to xsel
     If $(xsel,2,5)='     '
         Accept 'Enter a Room/Bed assignment ' to inbed
         Store inbed+'    ' to inbed
     else
         Store $(xsel,2,5) to inbed
         Store 'A     ' to xsel
       endif
       Store $(inbed,1,5) to inbed
       If !(inbed)<>'Q    '  .and. inbed<>'     '
         Store ' ' to names
         Store T to RBCHANGE
         Store F to RBAPPEND
         Store sfield+inbed to infind
         Find &infind
         If #<>0
           Store str(#,5) to oldrec
           If $(spact,15,10)<>'         '
             ? 'This Room/Bed code found with name - ',$(spact,15,22)
             ? 'No Add made.'
             Store F to RBCHANGE
           endif
         else
           Store T to RBappend
         endif
         If RBCHANGE
           ? 'Enter a new name for this Room/Bed.'
           Select primary
           Do CSECHECK.CMD
           If FOUND
            Store F to CHOLD
            Store $(last:name,1,11)+' '+$(first:name,1,10) to names
            If ROOM = '         '
              Store T to CHOLD
              Replace room with $(infind,6,9)
            else
              Store $(room,5,5) to xx
              Store 'ROOM='+room to nnfind
              Store $(last:name,1,11)+' '+$(first:name,1,10) to names
              Select secondary
              Find &nnfind
              If #=0 .or. names<>$(spact,15,22)
                Store T to CHOLD
                ? nnfind,' is not valid for - ',names,'Now being replaced.'
                Select primary
                Replace room with ' '
              else
                ? 'This name already has a Room/Bed. You must select another.'
              endif
            endif
          else
            ? 'This Room/Bed is added without a name.'
            store T to chold
            store T to RBAPPEND
          endif   * FOUND
          If CHOLD
            Select secondary
            If RBappend
              Append blank
              Store II+1 to II
            else
              GOTO &oldrec
            endif
            ? 'New Room/Bed assignment: ',$(infind,6,9),'-->',names
            Replace spact with infind+names
          endif
         endif * #<>0
      endif  * valid "inbed"
     Store 'A' to xsel
   CASE !(XSEL)='C' .or. !(XSEL)='D'
     Do CSELCHNG.CMD
   CASE !(xsel)='R'
      Release inbed,nnfind,ffind,oldrec,chold
      GOTO &xrec
      SKIP
      Set format to print
      Store ROMNAME+'   '+ename to xx
      If len(xx)>60
        Store $(xx,1,60) to xx
      endif
      @ 1,0 say xx
      @ 1,62 say curdate
      Store 1 to I
      Store 3 to J
      Store str(#,5) to irec
      Store '    0' to jrec
      Do while I<21.and.spact=sfield.and..not.EOF
        SKIP
        Store I+1 to I
      enddo
      If spact=sfield
        Store str(#,5) to Jrec
      endif
      GOTO &IREC
      Store 3 to I
      Do while (spact=sfield .and. I<23) .and. .not. EOF
        @ I,3 say $(spact,9,30)
        SKIP
        Store str(#,5) to irec
        If jrec<>'    0'
          GOTO &jrec
          @ I,40 say $(spact,9,30)
          SKIP
          Store str(#,5) to jrec
          If spact<>sfield
            Store '    0' to jrec
          endif
        endif
        Store I+1 to I
        GOTO &IREC
      enddo
      EJECT
      Set format to screen
 CASE !(xsel)='Q' .or.!(xsel)='S' .or. xsel=' '
 otherwise
   ? 'Invalid entry. Please enter again '
 endcase
 ?
enddo
enddo
endif
Release infield,romname,sfield,xrec,I,J,nobed,inbed,infind,found,names
Release nfind,nnfind,ffind,nfound,oldrec,CHOLD,irec,jrec
RETURN
r. !(XSEL)='D'
     Do CSELCHNG.CMD
   CASE !(xsel)='R'
      Release inbed,nnfind,ffind,oldrec,chold
      GOTO &xrec
      SKIP
      Set format to print
      Store ROMNAME+'   '+ename to xx
      If len(xx)>60
        Store $(xx,1,60) to xx
      endif
      @ 1,0 say xx